# Author: Mario Huys (mario_huys@hotmail.com)
# Description: Definition and implementation of the Array class.

package require Itcl

namespace eval iarray {

namespace export Array Sequence code escape

# Using itcl::code to pass internally created variables to other objects is problematic.
# Executing a method on this variable reference creates an extra stack level, possibly
# messing up with the use of the uplevel command. Therefore it's better to use a flat name,
# which can be produced with the following method.
proc code {var} {
	set coded [uplevel itcl::code [list $var]]
	
	set namespace [lindex $coded 2]
	set object [lindex $coded 3]
	if {[string equal -length 2 $object "::"]} {
		return $object
	} elseif {[string length $namespace] == 2} {
		return "::$object"
	} else {
		return "${namespace}::$object"
	}
}

# Escapes a string such that an exact match can be made in glob patterns. 
proc escape {str} {
	::regsub -all "\[\]\[\\\\*?\]" $str "\\\\&"
}

itcl::class Array {

	# Keeps track of the number of times objects are acquired within the arrays, deleting them if no longer acquired in any.
	private common cRegisterArray
	::array set cRegisterArray {}

	protected proc register {object} {
		if [::info exists cRegisterArray($object)] {
			incr cRegisterArray($object)
		} else {
			::set cRegisterArray($object) 1
		}
		#puts "Registering $object ([llength [array names cRegisterArray]] in)"
	}

	protected proc unregister {object} {
		if {![incr cRegisterArray($object) -1]} {
			::array unset cRegisterArray $object
			itcl::delete object $object
		}
		#puts "Unregistering $object ([llength [array names cRegisterArray]] left)"
	}

	constructor {args} {
		if {[llength $args] == 1} {
			::array set iArray [lindex $args 0]
		} else {
			::array set iArray $args
		}
	}
	destructor {
		foreach key $iControl {unregister [of $key]}
		::unset iArray
	}

	# Returns the value associated with the key. Will raise an error if the key is not present.
	method of {key} {return $iArray($key)}

	# Returns the value associated with the key or a default value if the key is not present.
	method on {key default} {if [has $key] {of $key} else {return $default}}

	# Checks if the key is present in this array.
	method has {key} {::info exists iArray($key)}

	# Checks if the array holds control over the object associated with the key.
	method controls {key} {expr [lsearch -exact $iControl $key] >= 0}
	
	# Returns a list with all the keys currently present.
	# Similar to an "::array names" command.
	method names {} {::array names iArray}

	# Retrieves the key-value pairs for which the key matches the pattern, returning a flat list.
	# Similar to an "::array get" command.
	method get {{pattern {*}}} {::array get iArray $pattern}

	# List is a flat list of key-value pairs, similar to the list in a "::array set" command.
	# Adds the key-value pairs to this array.
	method set {args} {
		if {[llength $args] == 1} {	::set list [lindex $args 0]} else {::set list $args}
		if [llength $iControl] {
			foreach {key value} $list {
				if {[::set idx [lsearch -exact $iControl $key]] != -1} {
					unregister [of $key]
					::set iControl [lreplace $iControl $idx $idx] 
				}
			}
		}
		::array set iArray $list
	}

	# Unsets (removes) the key-object pairs for which the key matches the pattern.
	# Note that in case you use this command to remove a single key, you may need to escape the
	# key to make it work. Use the iarray::escape procedure as in
	#   myArray unset [iarray::escape $key]
	# See the rename command for an alternative.
	method unset {{pattern {*}}} {
		if [llength $iControl] {
			if [string equal $pattern "*"] {
				foreach key $iControl {unregister [of $key]}
				::set iControl {}
			} else {
				::set idx 0
				foreach key $iControl {
					if [string match $pattern $key] {
						unregister [of $key]
						::set iControl [lreplace $iControl $idx $idx]
					} else {
						::incr idx
					}
				}
			}
		}
		::array unset iArray $pattern
	}

	# List is a flat list of key-value pairs (similar to the set command).
	# Adds the key-object pairs to the array (as in the set command) and takes control over the object,
	# deleting it when either the key is removed or gets a new value, or when the array is deleted.
	# The same object may be acquired multiple times in different arrays, in which case it will only be
	# deleted when it is no longer acquired in any array.
	method acquire {args} {
		if {[llength $args] == 1} {	::set list [lindex $args 0]} else {::set list $args}
		foreach {key value} $list {
			register $value
			if {[lsearch -exact $iControl $key] != -1} {
				unregister [of $key]
			} else {
				lappend iControl $key
			}
		}
		::array set iArray $list
	}

	# Removes control over the objects corresponding to the keys that match this pattern.
	# Does not remove the key-object pair!
	method unacquire {{pattern {*}}} {
		if [string equal $pattern "*"] {
			::set iControl {}
		} else {
			::set idx 0
			foreach key $iControl {
				if [string match $pattern $key] {
					::set iControl [lreplace $iControl $idx $idx]
				} else {
					::incr idx
				}
			}
		}
	}

	# List is a flat list of old key-new key pairs (similar to the set command).
	# Stores the object under a different name.
	# If the new key is the empty string (or omitted in case of the last key in the list), removes the key-value pair,
	# which provides an alternative for the unset command, one for which the key does not need to be escaped. E.g.
	#   myArray rename $key
	# removes a single key-value pair, provided that the key does not contain white space.
	method rename {args} {
		if {[llength $args] == 1} {	::set list [lindex $args 0]} else {::set list $args}
		foreach {old new} $list {
			if {![has $old]} continue
			if {![string length $new]} {
				if {[::set idx [lsearch -exact $iControl $old]] != -1} {
					unregister [of $old]
					::set iControl [lreplace $iControl $idx $idx]
				}
				::array unset iArray [iarray::escape $old]
				continue
			}
			if [string equal $old $new] continue
			if {[::set idx [lsearch -exact $iControl $new]] != -1} {
				unregister [of $new]
				::set iControl [lreplace $iControl $idx $idx]
			}
			if {[::set idx [lsearch -exact $iControl $old]] != -1} {
				::set iControl [lreplace $iControl $idx $idx $new]
			}
			::array set iArray "$new $iArray($old)"
			::array unset iArray [iarray::escape $old]
		}
	}

	# Returns a key not yet present in the array, by appending a number that makes the combination unique.
	method makeUnique {{key ""}} {
		for {::set idx 0} {[has "$key$idx"]} {::incr idx} {}
		return "$key$idx"
	}
	
	variable iArray
	variable iControl {}
}

# A sequence is an array where the keys are added in a certain order, which will be apparent when
# issuing a names or get command.
itcl::class Sequence {
	inherit Array

	constructor {args} {eval Array::constructor $args} {
		if {[llength $args] == 1} {	::set list [lindex $args 9]} else {::set list $args}
		foreach {key value} $list {
			if {[lsearch -exact $iNames $key] == -1} {lappend iNames $key}
		}
	}
	
	method names {} {return $iNames}

	method get {{pattern {*}}} {
		::set list {}
		foreach key $iNames {
			if [string match $pattern $key] {
				lappend list $key [of $key] 
			}
		}
		return $list
	}

	method set {args} {
		if {[llength $args] == 1} {	::set list [lindex $args 0]} else {::set list $args}
		foreach {key value} $list {
			if {[lsearch -exact $iNames $key] == -1} {lappend iNames $key}
		}
		eval Array::set $args
	}

	method unset {{pattern {*}}} {
		if [string equal $pattern "*"] {
			::set iNames {}
		} else {
			::set idx 0
			foreach key $iNames {
				if [string match $pattern $key] {
					::set iNames [lreplace $iNames $idx $idx]
				} else {
					::incr idx
				}
			}
		}
		Array::unset $pattern
	}

	method acquire {args} {
		if {[llength $args] == 1} {	::set list [lindex $args 0]} else {::set list $args}
		foreach {key value} $list {
			if {[lsearch -exact $iNames $key] == -1} {lappend iNames $key}
		}
		eval Array::acquire $args
	}

	method rename {args} {
		if {[llength $args] == 1} {	::set list [lindex $args 0]} else {::set list $args}
		foreach {old new} $list {
			if {[::set idx [lsearch -exact $iNames $old]] == -1} continue
			::set iNames [lreplace $iNames $idx $idx]
			lappend iNames $new	
		}
		eval Array::rename $args
	}

	# New methods

	method indexOf {key} {lsearch $iNames $key}

	method at {idx} {of [lindex $iNames $idx]}

	method move {key toIdx} {
		if {[string equal -length 3 $toIdx end]} {
			::set toIdx [expr "[llength $iNames][string range $toIdx 3 end]"]
		}
		::set idx [indexOf $key]
		if {$idx == $toIdx} {return $iNames}
		if {$idx < $toIdx} {
			::set iNames [eval [list lreplace $iNames $idx $toIdx] [lrange $iNames [expr $idx + 1] $toIdx] [list $key]]
		} else {
			::set iNames [eval [list lreplace $iNames $toIdx $idx $key] [lrange $iNames $toIdx [expr $idx - 1]]]
		}
	}

	variable iNames {}
}

}

package provide Iarray 1.0
